Celestin Apprentice 5/Apprentice-Release5.iso/Environments/CGIshell 1.3.2/samples/server.4th

Text File | 1996-04-23 | 15.7 KB | 434 lines | [TEXT/ALFA]

\
\
\  PF Forms Handler Shell  --  Web Server Interface, version 1.3.2
\
\
\  (c) Ronald T. Kneusel, 1995, 1996
\  ([e-mail])
\
\  This code may be used and distributed freely provided the copyright
\  notice remains intact and my name is mentioned in the documentation.
\
\  Last mod: 23-Apr-96
\  =========================================================================
\
\  Provides a shell for writing CGI applications for use with WebSTAR.  The
\  shell will handle all communication between WebSTAR and the CGI.  It also
\  provides a vocabulary for extracting the information presented by WebSTAR.
\
\
\  @Field ( addr1 addr2 new|append -- )
\
\      Get the post data string for the field whose address is
\      on the stack.  Place the data into the string at addr2.  @Field
\      will convert characters as necessary.
\
\  @Addr ( addr new|append -- )
\
\      Put the client's IP address in the string at addr
\
\  @Direct ( addr new|append -- )
\
\      Put the direct argument in the string at addr
\
\  @Browser ( addr new|append -- )
\
\      Put the browser type in the string at addr
\
\  REPLY ( addr -- )
\
\      Send the string back to WebSTAR.  Use only within  ae: ... ;ae
\

( yet more disk I/O words by C. Heilman )

\ create space for the fcb and a word to access it
variable FCB 78 allot  ( our File's Control Block )
: +FCB ( offset -- addr ) fcb + ;  ( offset into fcb )

\ setup for a (register based) file manager toolbox call
: FTRAP ( -- ) fcb >abs  ,$ 205E ;  ( movea.l [ps]+,a0 )

: CLOSE ( -- ) ftrap ,$ A001  ftrap ,$ A013 ;  ( _Close & _FlushBuffer )
: ?DERROR ( -- ) \ report error if result is not zero
    16 +fcb @ ?dup IF  ." DiskError" .  close  abort THEN ;

\ open a file with the address of a string of the pathname on the stack
: OPEN ( addr -- ) \ addr is a Forth style string - str[255]
    fcb 80 0 fill           \   clear the fcb for a new file
    >abs  18 +fcb  2!        \  set name of the file to string
    ftrap ,$ A000  ?derror ;  \ _Open the file in the fcb

\ create a file
: NEWFILE ( name.addr -- )
    fcb 80 0 fill           \   clear the fcb for a new file
    >abs  18 +fcb  2!        \  set name of the file to string
    ftrap ,$ A008  ?derror    ( _Create )
    ,s TEXT 32 +fcb 2!         \ TEXT type
    ftrap ,$ A00D ?derror ;   ( _SetFileInfo )

\ return the filesize !!! MUST BE <32K !!!
: @SIZE ( -- bytes ) ftrap ,$ A011  30 +fcb @ ;  ( _GetEOF )

\ set some fcb parameters
: !SIZE ( bytes -- ) 38 +fcb ! ;      \ set bytes-to-read/write
: !BUFF ( addr -- ) >abs 32 +fcb 2! ;  \ set read/write buffer pointer

\ read/write with buffer addr and bytes to read/write on the stack
: READ ( addr count -- )  !size !buff ftrap ,$ A002  ?derror ;  ( _Read )
: WRITE ( addr count -- ) !size !buff ftrap ,$ A003  ?derror ;  ( _Write )

\ read/write file a byte at a time to/from the stack
: GETCHR ( -- c ) here 1 read  here c@ ;
: PUTCHR ( c -- ) here c!  here 1 write ;

\ read until character (c) is encountered
: CREAD ( addr c -- bytes_read )
    44 +fcb c!  128 45 +fcb c!  \ setup ioPosMode
    @SIZE read  42 +fcb @ ;     \ put lowbyte of ioActCount on stack

\ A defining word for strings
: $[  \ compiling: ( -- ) enclose a ] terminated string
    CREATE  93 word here  c@ 1+ dup 2 mod +  allot
    DOES>  ;  \ runtime action: ( -- addr ) \ <<-- no count!

( end I/O words )


( *************************** String Functions **************************** )
( Strings 10/15/95 23:30:19 )
\
\ These words deal with 0 terminated strings.
\
\ The names maintain compatability with the word-set in
\  _Library of Forth Routines and Utilities_  by  James D. Terry
\  (c) 1986 Shadow Lawn Press  ISBN 0-452-25841-3
\
\ In comments, string is the starting address of a zero terminated string,
\ and len is the length not including the zero. String[255] is a length
\ byte preceded string, with a max length of 255 bytes.
\
\ String format:
\ string address is first byte ->This is a string.0<- Ends with a zero

\ *** Most of these routines written by C. Heilman ***

\ Length and $clear get used a lot - do them in ml.
: LENGTH ( string -- len )  \ length of the string at addr
 ( was:  dup >r BEGIN dup c@ WHILE 1+ REPEAT  r> - ; )
    ,$ 3016          \     move (ps),d0
    ,$ 4a33 ,$ 0000  \ @0: tst.b 0(bp,d0.w)
    ,$ 6706          \     beq.s @1
    ,$ 0640 ,$ 0001  \     addi #1,d0
    ,$ 60f4          \     bra.s @0
    ,$ 9056          \ @1: sub (ps),d0
    ,$ 3c80 ;        \     move d0,(ps)

: $CLEAR  ( string -- ) \ erase a string ( equivalent to: 0 swap c! ; )
   ,$ 301E  ,$ 4233 ,$ 0000 ;  \ move (ps)+,d0  clr.b 0(bp,d0.w)

\ The next 4 words are directly from Ron's CGI Framework.

\ Convert between null terminated and length byte preceeded type strings.
: >NULL ( string[255] -- )  \ convert a string[255] into a string
    dup c@ 2dup + >r swap dup 1+ swap rot cmove  r> $clear ;

: >COUNT ( string -- ) \ convert a string into a string[255]
    dup length >r dup dup 1+ r cmove  r> swap c! ;


\ Terminal I/O.
: 0TYPE ( string -- )  \ type null terminated string
    dup length dup IF type ELSE 2drop THEN ;

: ACCEPT ( string len -- )  \ like expect but stores zero at end of line
    2dup 1+ 0 fill  >r dup r> expect dup length 1- + $clear ; ( bug fixed)


\ Test a string's content.
: $= ( string1 string2 -- f ) \ true if string2,len2 = string1,len1
    dup length 1+  -1 swap 2swap rot 0 DO  \ set flag to true
      over r + c@  over r + c@  =         \  check each byte
      0= IF rot 1+ rot rot leave THEN    \   change flag to false
    LOOP 2drop ;


\ Manipulate strings.
: $COPY ( source.string dest.string -- ) \ copy source to dest
    over length 1+ cmove ;

: $+ ( source.string dest.string -- ) \ append source to the end of dest
    dup length + $copy ;

: $LEFT ( string len -- ) \ clip string to len chars
    over length min  +  $clear ;

: $RIGHT ( string len -- ) \ clip string to rightmost len characters
    over length over - 0> IF
      over length over -  rot dup rot +  swap rot 1+  cmove
    ELSE 2drop THEN ;

: $MID ( string start len -- ) \ clip string to len section at start
    rot rot over length  swap - 1+  >r dup r> $right  swap $left ;

: $UPPER ( string -- ) dup >count  dup upper  dup >null drop ; \ uppercase

: $CHAR ( character string -- ) dup length + dup >r c! 0 r> 1+ c! ;


\ Find and replace with strings.
variable POS  ( local variable )
: $FIND ( string1 string2 -- pos ) \ find string2 in string1; 0 if unfound
    0 pos !
    over length over length - 2+  1  DO
      over here $copy
      here  over length  r swap  $mid
      here over
      $= IF  r pos !  leave THEN
    LOOP  2drop
    pos @ ;

: $REPLACE ( dest.string1 find.string2 replace.string3 -- )
    rot >r swap
    r over $find ?dup IF  \   IF string2 is found in string1
      r here $copy         \  THEN replace string2 with string3
      r over 1-  $left      \  modify string1
      rot r $+
      swap length +           \        !!! IMPORTANT !!!
      here length  swap - 1+   \   DOES NOT CHECK FOR OVERWRITE
      here swap $right          \  String1 MUST accomodate any
      here r> $+                 \ additional bytes from string3
    ELSE 2drop r> drop  THEN ;

\ Create and assign strings of several varieties.
: $CONSTANT  \ compiling: ( -- ) name a string terminated with '}'
    CREATE  125 word here c@ 1+ dup 2 mod + allot  0 [compile] ,
    DOES>  count drop ;  \ runtime action: ( -- string )
\ This uses a curley brace because they aren't used much on web pages.
\   eg:  $constant ESERROR Empty stack!}

: $VARIABLE CREATE 1+ allot ;  \ compiling: ( len -- ) name an empty string
\   eg:  80 $variable INPUTLINE  inputline ${ Hi there!}

: $ARRAY \ create named string arrays - name from input stream
    CREATE  dup ,  * allot    \ compiling: ( number_of_.strings len -- )
    DOES>  dup @ rot * + 2+ ;  \ runtime: ( string_number -- string )
\   eg:  15 64 $array ERRORMESSAGES
\        0 errorMessages ${ Error!}

\ NOTE: Constants and variables are identical except that constants
\       have no room to grow, but variables _may_ have extra memory
\       allotted to them to grow into.  Also constants are assigned
\       when they are created, while variables (and arrays, which are
\       lists of variables) must be assigned seperately (see below).

: ${ ( string -- ) \ assign text to a string from the input stream.
    125 word  here >null  here swap $copy ;
\   eg:  inputLine ${ Something to say!}    *** NO OVERWRITE CHECK ***

: MESSAGE[  \ compiling: ( -- ) enclose subsequent ']'ed string
    CREATE  93 word here  c@ 1+ dup 2 mod +  allot  0 [compile] ,
    DOES>  count drop ;  \ runtime action: ( -- addr )

: STRING>>  \ compiling: ( n -- )  number of bytes in the string
    CREATE  allot ;

: <> = 0= ; macro

: newstr  ( addr -- )  \ zero a string
   0 swap c! ;

: strcpy ( str1 str2 -- ) \ copy string 1 to string 2
    dup length + >r  \ automatically append
    BEGIN  dup c@ 0 <>  WHILE
      dup c@ r c!  r> 1+ >r  1+
    REPEAT  0 r> c!  ;

: strncpy ( str1 str2 -- ) \ copy as above, clear str2 first
    dup newstr  strcpy ;

: 0type ( addr -- )  \ type null terminated string
    dup length dup 0 <> IF type ELSE 2drop THEN ;

: >null ( addr -- )  \ convert a counted string into a null terminated string
    dup c@ 2dup + >r swap dup 1+ swap rot cmove  0 r> c! ;

: >count ( addr -- ) \ convert a null terminated string into a counted string
    dup length >r dup dup 1+ r cmove  r> swap c! ;

: accept ( addr len -- )  \ like expect but no blank at end of line
    swap dup >r swap expect  0 r r> length 1- c! ;


( **************** Apple Event and reply string handler ******************* )

\ This code courtesy of C. Heilman, slight mods RTK

2variable DDATA  4 allot

MESSAGE[ SERROR  Empty stack!]

( get AEDesc handle from an Apple Event )
: ?DESC ( d.key d.type -- desc.handle desc.type -1  or  0 )
    0 >r                                  ( room for error        )
    202 +md 2@ 2>r                        ( the AppleEvent handle )
    2swap 2>r  2>r                        ( keyword and type      )
    here a>r                              ( receiving address     )
    ,$ 303C ,$ 812 ,$ A816 ( AEGetParamDesc: move #$812,d0 _Pack8 )
    r> 0= IF                              ( if there is no error  )
      here 4 + 2@  here 2@  -1            ( get data & leave true )
    ELSE  0 THEN ;                        ( or else leave false   )

: -DESC ( addr.where.desc.is.stored -- error ) ( remove desc rec. )
    0 >r  a>r                          ( push room and descriptor )
   ,$ 303C ,$ 0204 ,$ A816 ( AEDisposeDesc: move #$0204,d0 _Pack8 )
    r> ;

2variable DSIZE  \ this double variable holds the size of a string in dbuff
variable  DBUFF 4094 allot  \ this block is filled with a text string

( get AE data from an Apple Event )
: ?DATA ( d.key -- addr  -1  or  0 )
    0 >r               \ make room on stack for error
    202 +md 2@ 2>r      \ push theAppleEvent address
    2>r  ,s TEXT 2>r     \ push keyword (from pstack) and desired type (TEXT)
    here a>r              \ push an address to hold the actual type
    dbuff a>r              \ push the data receiving address
    4096 s>d 2>r            \ max number of bytes to read
    dsize a>r                \ push a variable to hold the actual size
    ,$ 303C ,$ 0E11 ,$ A816   \ AEGetParamPtr: move #$812,d0 _Pack8
    r> 0= IF                   \ if there is no error
\      dbuff  dsize 2@ drop  -1  \ put address, count and true on pstack
       0 dbuff dsize 2@
       drop + c!  dbuff -1      \ make null terminated
    ELSE  0 THEN ;               \ else false

\ Reply to an Apple Event with a string
: REPLY ( addr -- )  \ **** USE INSIDE OF A HANDLER ONLY ****
    dup length                \ how long is it?
    0 >r                      \ put room for error on rstack
    198 +md 2@ 2>r            \ put the ReplyEvent handle on rstack
    ,s ---- 2>r  ,s TEXT 2>r  \ put keyword and type on rstack
    swap a>r  0 2>r           \ put addr & count on rs from pstack
    ,$ 303C ,$ 0A0F ,$ A816   \ AEPutParamPtr: move #$A0F,d0 _Pack8
    r> drop ;                 \ ignore any error


( ******************* Words to get field data *********************** )

 0 constant NEW     \ start a new string
-1 constant APPEND  \ append at end of existing string

variable theAddr    \ holds the address of the string

: zeroStr ( -- )  \ zero the string in theAddr
   0 theAddr @  c! ;

: >append ( c -- )  \ put a character on the end of theAddr
   theAddr @ length  theAddr @ + dup >r c!     \ character
   0 r> 1+ c! ;  \ null

: count>str  ( addr len -- )  \ copy characters into the string
   >r dup r> + swap DO
     r c@ >append
   LOOP ;

variable <str>  \ address of target string

: h>d ( c -- d )  \ hex digit to decimal, no error checking
   dup 64 > IF  55 -  ELSE  48 -  THEN ;

: hex>char ( addr --  )  \ convert a %xx sequence into a character
   1+ dup c@  swap  1+ c@
   h>d swap h>d 16 * +
   dup 32 < IF
     13 = IF  13 <str> @ $CHAR THEN  \ return character
   ELSE
     <str> @ $CHAR  \ anything >= space
   THEN
;

: $copy+ ( s1 len s2 -- )  \ copy s1 to s2 changing %nn codes to characters
   <str> !  \ keep address of target string
   swap dup rot + swap DO
     r c@
     dup 43 = IF  drop  32 <str> @ $CHAR  1  ELSE  \ '+' to space
     dup 37 = IF  drop  r hex>char 3         ELSE  \ %xx
     <str> @ $CHAR  1 THEN THEN                    \ alphanumeric character
   +LOOP
;

create ~cr  3 allot  13 ~cr c! 10 ~cr 1+ c!  0 ~cr 2+ c!
: +crlf  ~cr swap strcpy ;   \ add a <cr><lf> pair

message[ rt0 <html>]
message[ rt1 </html>]

: startString ( addr -- )  ( load the header text into string )
   rt0 swap strcpy ;
: endString ( addr -- ) rt1 swap strcpy ;  ( ending text )

( *************************** Number <--> String ************************* )

: f>str ( f addr -- )   \ convert a float to a string in addr
    depth 4 > IF   \ original CH, modified by RTK
      theAddr !  zeroStr \ dest address
      @pen 2>r  10 +md @ >r  30000 10 +md ! \ move pen offscreen
      3000 3000 !pen f.         \ print float: string is at here
      r> 10 +md !  2r> !pen     \ return pen to origonal position
      here count count>str      \ put it addr
    ELSE serror THEN ;

create b#! 80 allot  \ buffer for string conversion
: str>f ( addr -- f )  \ convert a string into a float
   dup >r b#! r> length 1+ cmove   \ move to buffer
   b#! 1- >abs fnumber ;  \ and convert

( ********************** User level words ************************* )

: @Direct ( addr new|append -- )  \ get the direct argument
   swap theAddr !   \ store the string address
   NEW = IF zeroStr THEN  \ clear the string
   ,s ---- ?data IF  theAddr @ $+  THEN  \ get the argument
;

: @Addr  ( addr new|append -- )  \ get the IP address
   swap theAddr !   \ store the string address
   NEW = IF zeroStr THEN  \ clear the string
   ,s addr ?data IF theAddr @ $+  THEN  \ get it
;

: @Browser ( addr new|append -- )  \ get the browser type
   swap theAddr !   \ store string address
   NEW = IF zeroStr THEN
   ,s Agnt ?data IF  theAddr @ $+  THEN  \ get it
;

variable $fld   \ holds field name
variable $adr   \ holds address
variable $out   \ holds output string
message[ & &]  \ end of field data marker

: @Field ( addr1 addr2 new|append -- ) \ get the data for a field
   NEW = IF  swap dup $CLEAR swap  THEN
   $fld !          \ address of field name string
   61 $fld @ $CHAR  \ add an "="
   $out !   \ address of output string
   ,s post ?data IF  \ there is post data
     $adr !
     $adr @ $fld @ $FIND dup 0= IF
       drop         \ no field data
       0 $out @ c!  \ empty string
     ELSE
       1- $fld @ length + $adr @ + \ found the field
       dup & $FIND dup 0= IF
          drop dup length      \ end of string
       ELSE 1- THEN            \ not end of string
       $out @ $copy+           \ put it in the string
     THEN
   THEN
   0 $fld @ dup length 1- + c!  \ remove "="
;

\ on to field.4th